! (C) Copyright 2000- ECMWF.
! (C) Copyright 2000- Meteo-France.
! 
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.
!

MODULE DIST_GRID_32_CTL_MOD_dp
CONTAINS
SUBROUTINE DIST_GRID_32_CTL(PGPG,KFDISTG,KPROMA,KFROM,PGP)

!**** *DIST_GRID_32_CTL* - Distributing global gridpoint array to processors

!     Purpose.
!     --------
!        Routine for distributing gridpoint array

!**   Interface.
!     ----------
!     CALL DIST_GRID_32_CTL(...)

!     Explicit arguments : 
!     -------------------- 
!     PGPG(:,:)   - Global gridpoint array
!     KFDISTG     - Global number of fields to be distributed
!     KPROMA      - required blocking factor for gridpoint output
!     KFROM(:)    - Processor responsible for distributing each field
!     PGP(:,:,:)  - Local spectral array

!     Externals.  SET2PE - compute "A and B" set from PE
!     ----------  MPL..  - message passing routines

!     Author.
!     -------
!        Mats Hamrud *ECMWF*

!     Modifications.
!     --------------
!        Original : 2000-04-01

!     ------------------------------------------------------------------

USE EC_PARKIND  ,ONLY : JPIM     ,JPRM
USE MPL_MODULE

USE TPM_DISTR ,ONLY : D, NPROC, MYPROC, NPRCIDS, MTAGDISTGP
USE TPM_GEOMETRY, ONLY : G

USE SET2PE_MOD, ONLY : SET2PE
USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS
USE EQ_REGIONS_MOD, ONLY : N_REGIONS, N_REGIONS_NS

IMPLICIT NONE

! Declaration of arguments

REAL(KIND=JPRM)    ,OPTIONAL, INTENT(IN)  :: PGPG(:,:)
INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFDISTG
INTEGER(KIND=JPIM)          , INTENT(IN)  :: KPROMA
INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFROM(:)
REAL(KIND=JPRM)             , INTENT(OUT) :: PGP(:,:,:)

! Declaration of local variables

REAL(KIND=JPRM),ALLOCATABLE :: ZBUF(:,:,:),ZRCV2(:,:)
REAL(KIND=JPRM)    :: ZRCV(D%NGPTOTMX,KFDISTG)
INTEGER(KIND=JPIM) :: JFLD,JB,JA,IGLOFF,IGL1,IGL2,IOFF,ILAST,ILOFF,ILENR
INTEGER(KIND=JPIM) :: JGL,JLON,ISND,ITAG,J,IRCV
INTEGER(KIND=JPIM) :: JKGLO,IEND,JROF,IBL,JROC
INTEGER(KIND=JPIM) :: ISENDREQ(NPROC,KFDISTG),ILEN(NPROC,KFDISTG)
INTEGER(KIND=JPIM) :: IFROM,IMYFIELDS,IFLD,IFLDSFROM(NPROC)
LOGICAL :: LLSAME

!     ------------------------------------------------------------------

! Copy for single PE

IF(NPROC == 1) THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
  DO JKGLO=1,D%NGPTOT,KPROMA
    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
    IOFF = JKGLO-1
    IBL  = (JKGLO-1)/KPROMA+1
    DO JFLD=1,KFDISTG
      DO JROF=1,IEND
        PGP(JROF,JFLD,IBL) = PGPG(IOFF+JROF,JFLD) 
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO

ELSEIF(KFDISTG>0) THEN

! test if values in KFROM are all the same
  LLSAME=.TRUE.
  IFROM=KFROM(1)
  DO JFLD=2,KFDISTG
    IF(KFROM(JFLD) /= IFROM) THEN
      LLSAME=.FALSE.
      EXIT
    ENDIF
  ENDDO

  IMYFIELDS = 0
  DO JFLD=1,KFDISTG
    IF(KFROM(JFLD) == MYPROC) THEN
      IMYFIELDS = IMYFIELDS+1
    ENDIF
  ENDDO

  CALL GSTATS(1663,0)
  IF(IMYFIELDS > 0) THEN
    ALLOCATE(ZBUF(D%NGPTOTMX,IMYFIELDS,NPROC))

!$OMP PARALLEL DO SCHEDULE(DYNAMIC,1)&
!$OMP&PRIVATE(JFLD,JA,JB,ISND,IGLOFF,IGL1,IGL2,IOFF,ILAST,J,&
!$OMP&ILOFF,JGL,JLON)
    DO JFLD=1,IMYFIELDS
      DO JA=1,N_REGIONS_NS
        DO JB=1,N_REGIONS(JA)
          CALL SET2PE(ISND,JA,JB,0,0)

          IGLOFF = D%NPTRFRSTLAT(JA)
          IGL1   = D%NFRSTLAT(JA)
          IGL2   = D%NLSTLAT(JA)
          IOFF = 0
          IF(JA > 1) THEN
            IF( D%NLSTLAT(JA-1) == D%NFRSTLAT(JA) )THEN
              ILAST = D%NLSTLAT(JA-1)-1
            ELSE
              ILAST = D%NLSTLAT(JA-1)
            ENDIF
            DO J=D%NFRSTLAT(1),ILAST
              IOFF = IOFF+G%NLOEN(J)
            ENDDO
          ENDIF
          
          ILEN(ISND,JFLD) = 0
          ILOFF = 0
          DO JGL=IGL1,IGL2
            DO JLON=1,D%NONL(IGLOFF+JGL-IGL1,JB)
              ZBUF(ILEN(ISND,JFLD)+JLON,JFLD,ISND) = &
               & PGPG(IOFF+ILOFF+D%NSTA(IGLOFF+JGL-IGL1,JB)+JLON-1,JFLD)
            ENDDO
            ILEN(ISND,JFLD) = ILEN(ISND,JFLD) + D%NONL(IGLOFF+JGL-IGL1,JB)
            ILOFF = ILOFF + G%NLOEN(JGL)
          ENDDO
        ENDDO
      ENDDO
    ENDDO
!$OMP END PARALLEL DO
  ENDIF
  CALL GSTATS(1663,1)
    
  ! Message passing
  CALL GSTATS_BARRIER(791)
  CALL GSTATS(811,0)
  ! Send
  IF( LLSAME )THEN
    IF(KFROM(1) == MYPROC) THEN
      ITAG = MTAGDISTGP
      DO JROC=1,NPROC
        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
         &CDSTRING='DIST_GRID_32_CTL')
      ENDDO
    ENDIF
  ELSE
   IF(IMYFIELDS > 0) THEN
      ITAG = MTAGDISTGP
      DO JROC=1,NPROC
        CALL MPL_SEND(ZBUF(:,:,JROC),KDEST=NPRCIDS(JROC),KTAG=ITAG,&
         &KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ(JROC,1),&
         &CDSTRING='DIST_GRID_32_CTL')
      ENDDO
    ENDIF
  ENDIF
      
    ! Receive

  IF( LLSAME )THEN
    IRCV = KFROM(1)
    ITAG = MTAGDISTGP
    CALL MPL_RECV(ZRCV,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
     &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:')
    IF( ILENR /= D%NGPTOTMX*KFDISTG )THEN
      CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 1')
    ENDIF
  ELSE
    IFLDSFROM(:)=0
    DO JFLD=1,KFDISTG
      IFLDSFROM(KFROM(JFLD)) = IFLDSFROM(KFROM(JFLD))+1
    ENDDO
    ITAG = MTAGDISTGP
    DO JROC=1,NPROC
      IF(IFLDSFROM(JROC) > 0 ) THEN
        IRCV = JROC
        ALLOCATE(ZRCV2(D%NGPTOTMX,IFLDSFROM(JROC)))
        CALL MPL_RECV(ZRCV2,KSOURCE=NPRCIDS(IRCV),KTAG=ITAG,&
         &KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=ILENR,CDSTRING='DIST_GRID_32_CTL:')
        IF( ILENR /= D%NGPTOTMX*IFLDSFROM(JROC) )THEN
          CALL ABORT_TRANS(' DIST_GRID_32_CTL: INVALID RECEIVE MESSAGE LENGTH 2')
        ENDIF
        IFLD = 0
        DO JFLD=1,KFDISTG
          IF(KFROM(JFLD) == JROC) THEN
            IFLD = IFLD+1
            ZRCV(1:D%NGPTOT,JFLD) = ZRCV2(1:D%NGPTOT,IFLD)
          ENDIF
        ENDDO
        DEALLOCATE(ZRCV2)
      ENDIF
    ENDDO
  ENDIF

! Wait for send to complete

  IF( LLSAME )THEN
    IF(KFROM(1) == MYPROC) THEN
      CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
       & CDSTRING='DIST_GRID_32_CTL: WAIT 1')
    ENDIF
  ELSEIF(IMYFIELDS > 0) THEN
    CALL MPL_WAIT(KREQUEST=ISENDREQ(:,1), &
     & CDSTRING='DIST_GRID_32_CTL: WAIT 2')
  ENDIF
  CALL GSTATS(811,1)
  CALL GSTATS_BARRIER2(791)

  CALL GSTATS(1663,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,IEND,IOFF,IBL,JFLD,JROF)
  DO JKGLO=1,D%NGPTOT,KPROMA
    IEND = MIN(KPROMA,D%NGPTOT-JKGLO+1)
    IOFF = JKGLO-1
    IBL  = (JKGLO-1)/KPROMA+1
    DO JFLD=1,KFDISTG
      DO JROF=1,IEND
        PGP(JROF,JFLD,IBL) = ZRCV(IOFF+JROF,JFLD) 
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1663,1)
  !Synchronize processors
  CALL GSTATS(786,0)
  CALL MPL_BARRIER(CDSTRING='DIST_GRID_32_CTL:')
  CALL GSTATS(786,1)
  IF(ALLOCATED(ZBUF)) DEALLOCATE(ZBUF)
ENDIF

!     ------------------------------------------------------------------

END SUBROUTINE DIST_GRID_32_CTL
END MODULE DIST_GRID_32_CTL_MOD_dp




